home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Dylan Related / Thomas / MacGambit⁄Thomas / MacGambit⁄Thomas Sources / Reference Notes / Vector.scm < prev   
Encoding:
Text File  |  1995-03-15  |  2.6 KB  |  70 lines  |  [TEXT/gamI]
  1. ; ----------------------------------------------------------------------------
  2. ; File:        Vector.scm
  3. ; Description: vector manipulation functions
  4. ; Author:      Raymond Laning at ART
  5. ; Created:     28-Apr-93
  6. ; Modified:    07-Dec-93  23:18:51 Raymond Laning
  7. ; Language:    Scheme
  8. ; Status:      Experimental (Do Not Distribute)
  9. ;
  10. ;          (c) Copyright 1993, Advanced Robotic Technologies, Inc.
  11. ;              All Rights Reserved.
  12. ; ----------------------------------------------------------------------------
  13.  
  14. ;;;vector-copy copies the original vector into the destination vector
  15. ;;;starting at the start index in destination and stopping at the stop index
  16. ;;;in destination:  the original vector starts at offset
  17. (define (vector-copy original destination start-index end-index offset)
  18.   (do ((i start-index (+ i 1))
  19.        (j offset (+ j 1)))
  20.       ((> i end-index))
  21.     (vector-set! destination i (vector-ref original j))))
  22.  
  23. ;;;ditto, only for arrays
  24. (define (array-copy original destination start-index end-index offset flip?)
  25.   (do ((i start-index (+ i 1))
  26.        (j offset (+ j 1))
  27.        (dims (get original 'dims)))
  28.       ((> i end-index))
  29.     (do ((k 0 (+ k 1)))
  30.         ((>= k (cadr dims)))
  31.       (array-set!
  32.        destination i k 
  33.        (array-ref original (if flip? (- end-index j) j) k)))))
  34.  
  35. ;;;vadd adds two vectors vec1 and vec2 provided they are of the same length
  36. (define (vadd vec1 vec2)
  37.   (let* ((size (vector-length vec1))
  38.          (out (make-vector size)))
  39.     (if (= size (vector-length vec2))
  40.       (do ((i 0 (+ 1 i)))
  41.           ((>= i (vector-length vec1)) out)
  42.         (vector-set! out i (+ (vector-ref vec1 i) (vector-ref vec2 i))))
  43.       (error "different length vectors:"
  44.              (vector-length vec1)
  45.              (vector-length vec2)))))
  46.  
  47. (define (scalar* scalar vec)
  48.   (do ((i 0 (+ i 1)))
  49.       ((>= i (vector-length vec)) vec)
  50.     (vector-set! vec i (* scalar (vector-ref vec i)))))
  51.  
  52. ;(define (cross-product vector1 vector2)
  53. ;  (list (- (* (list-ref vector1 1) (list-ref vector2 2))
  54. ;           (* (list-ref vector1 2) (list-ref vector2 1)))
  55. ;        (- (* (list-ref vector1 2) (list-ref vector2 0))
  56. ;           (* (list-ref vector1 0) (list-ref vector2 2)))
  57. ;        (- (* (list-ref vector1 0) (list-ref vector2 1))
  58. ;           (* (list-ref vector1 1) (list-ref vector2 0)))))
  59.  
  60. (define (list-dot-product vector1 vector2)
  61.   (apply + (map * vector1 vector2)))
  62.  
  63. (define (list-magnitude vector)
  64.   (sqrt (apply  + (map (lambda (foo) (* foo foo)) vector))))
  65.  
  66. (define (included-angle vector1 vector2)
  67.   (let ((mag1 (list-magnitude vector1))
  68.         (mag2 (list-magnitude vector2)))
  69.     (acos (/ (list-dot-product vector1 vector2) (* mag1 mag2)))))
  70.